home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-printers.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  5.5 KB  |  179 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         zebu-printers.l
  3. ; Description:  printing functions for grammar debugging
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:       4-Aug-92
  6. ; Modified:     Mon Apr 11 14:11:30 1994 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1992, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17.  
  18. (IN-PACKAGE  "ZEBU")
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;                     printing the internals of a grammar
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23.  
  24. (defun print-actions (grammar &optional (stream t))
  25.   (let ((g (find-grammar (string grammar))))
  26.     (if (null g)
  27.     (error "No Grammar named ~S loaded" grammar)
  28.       (let ((*package* (grammar-package g))
  29.         (zb-rules (grammar-zb-rules g)))
  30.     (dotimes (i (length zb-rules))
  31.       (let ((pair (svref zb-rules i)))
  32.         (format stream "~%~%Rule: ~S" (car pair))
  33.         (dolist (prod (zb-rule--productions (cdr pair)))
  34.           (let ((action (production-rhs--build-fn prod)))
  35.                 #+MCL (print action stream)
  36.         #-MCL (pprint action stream)))))
  37.     (values)))))
  38.  
  39. (defun print-production (prod)
  40.   (format t "~A: ~A -> "
  41.       (production-index prod) (g-symbol-name (lhs prod)))
  42.   (dolist (x (rhs prod))
  43.     (princ (g-symbol-name x)) (princ " ")))
  44.  
  45. (defun print-productions ()
  46.   (dolist (x (reverse *productions*))
  47.     (print-production x) (terpri)))
  48.  
  49. (defun print-symbols ()
  50.   (dolist (sym (reverse *symbols*))
  51.     (format t "~A: ~A~%" (g-symbol-index sym) (g-symbol-name sym)))
  52.   )
  53.  
  54. (defun print-own-productions (sym)
  55.   (dolist (x (g-symbol-own-productions sym))
  56.     (print-production x) (terpri)))
  57.  
  58. (defun print-rhs-productions (sym)
  59.   (dolist (x (g-symbol-rhs-productions sym))
  60.     (print-production x) (terpri)))
  61.  
  62. (defun cruise-symbols ()
  63.   (dolist (sym (reverse *symbols*))
  64.     (format t "~%~A: ~A~%"
  65.         (g-symbol-index sym)
  66.         (g-symbol-name sym))
  67.     (when (g-symbol-own-productions sym)
  68.       (format t "Own productions:~%")
  69.       (print-own-productions sym))
  70.     (when (g-symbol-rhs-productions sym)
  71.       (format t "RHS productions:~%") 
  72.       (print-rhs-productions sym))
  73.     (princ "----------------------------")
  74.     ))
  75.  
  76. (defun cruise-symbols-2 ()
  77.   (terpri)
  78.   (dotimes (i (length *symbol-array*))
  79.     (let ((sym (svref *symbol-array* i)))
  80.       (format t "~S: ~S~%"
  81.           (g-symbol-index sym)
  82.           (g-symbol-name sym)))))
  83.  
  84. (defun cruise-follow-sets ()
  85.   (let (*print-circle*)
  86.     (dolist (gs *symbols*)
  87.       (when (g-symbol-non-terminal? gs)
  88.     (format t "~%~A: ~S~%--------------------"
  89.         gs
  90.         (oset-item-list (g-symbol-follow-set gs)))))))
  91.  
  92. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93.  
  94. (defun print-collection (closures-too?)
  95.   (format t "~%Start state index: ~A~%" *lr0-start-state-index*)
  96.   (oset-for-each
  97.    #'(lambda (item-set)
  98.        (format t "------------------ ~A -------------------~%"
  99.            (item-set-index item-set))
  100.        (item-set-print-kernel item-set closures-too?)
  101.        (let ((gotos (item-set-goto-map item-set)))
  102.      (when (oset-item-list gotos)
  103.        (princ "gotos: ")
  104.        (oset-for-each
  105.         #'(lambda (gmelt)
  106.         (format t "~A -> ~A  "
  107.             (g-symbol-name (car gmelt))
  108.             (item-set-index (cdr gmelt))))
  109.         gotos)
  110.        (terpri)))
  111.        )
  112.    *lr0-item-sets*))
  113.          
  114. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  115. (defun item-print (item &optional (stream t) level)
  116.   ;; This only prints the lr(0) parts and the lookaheads.
  117.   (declare (ignore level))
  118.   (let ((after-dot (item-after-dot item))
  119.     (production (item-production item)))
  120.     (format stream "~A -> " (g-symbol-name (lhs production)))
  121.     (do ((ncdr (rhs production) (cdr ncdr))
  122.      (i 0 (1+ i)))
  123.     ((null ncdr)
  124.      (when (= after-dot i) (princ ". "))
  125.      (unless (oset-empty? (item-look-aheads item))
  126.        (princ "{ "  stream)
  127.        (oset-for-each
  128.         #'(lambda (gs) (format stream "~A " (g-symbol-name gs)))
  129.         (item-look-aheads item))
  130.        (princ "}"  stream)))
  131.       (format stream "~:[~;. ~]~A "
  132.           (= after-dot i)
  133.           (g-symbol-name (car ncdr))))))
  134.  
  135. (defun item-list-print (item-list)
  136.   (dolist (item item-list)
  137.     (terpri)
  138.     (item-print item)))
  139.  
  140.  
  141. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  142.  
  143. (defun cruise-parse-tables ()
  144.   (format t "Start-state is ~S" *lr0-start-state-index*)
  145.   (dotimes (i *lr0-item-set-count*)
  146.     (format t "~%~A~%actions: " i)
  147.     (oset-for-each
  148.      #'(lambda (action-elt)
  149.      (format t "~A : ~A ~A  "
  150.          (get-print-name (car action-elt))
  151.          (cadr action-elt)
  152.          (caddr action-elt)))
  153.      (svref (the vector *action-array*) i))
  154.     (format t "~%gotos: ")
  155.     (oset-for-each
  156.      #'(lambda (goto-elt)
  157.      (format t "~A : ~A  "
  158.          (get-print-name (car goto-elt))
  159.          (cdr goto-elt))
  160.      )
  161.      (svref (the vector *goto-array*) i))
  162.     (format t "~%--------------------------------------------------")
  163.     ))
  164.  
  165. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  166. ;;; test:
  167. #||
  168.  (load "zebu-loadgram")
  169.  (load-grammar "ex1.grm")
  170.  (print-symbols)
  171.  (cruise-symbols)
  172.  (cruise-symbols-2)
  173.  (print-productions)
  174. ||#
  175.  
  176. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  177. ;;                           End of zebu-printers.l
  178. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  179.